\ redefer 05.1.28 4:54 pm NAB
\ Make a kernel word user-deferred.
\ Copies the word and then
\ re-vectors the original through a
\ user-deferred word of the same
\ name.
\ Does not work on inline words.
\ Makes no sense to perform on
\ immediate words, and will fail on
\ many.

needs core-ext

module redefer

: duplicate ( oldxt -- newxt )
\ Copy a word to a new unnamed xt:
  >r  :noname
  r@ xt>abs  r> xt>size
\ Word must be at least 4 bytes long:
  dup  4 < -21 and  throw
\ Copy word to new :noname word:
  2/ 0 do  2dup  i cells m+  @a
  dup (hex) ff00 and (hex) 6100 =
    abort" cannot redefer"
  cs,  loop
  2drop
  postpone ;
\ Copy has an extra trailing rts --
\  not worth adjusting for.
;

public:

: force-defer ( "name" -- )
\ Force a word to be kernel-deferred.
\ Fail if word is flagged inline:
  >in @  parse-word (find)  \ 3=inline
    nip  3 = if  drop  -21  throw
    then
  >in !
\ Exit if word is already deferred:
  ' dup deferred? if  drop  exit  then
  ." Duplicating non-deferred word" cr
  dup duplicate
\ Patch original word with a jump to
\  the new copy:
  swap  (hex) 4eea  over cs!
  defer! ;

: redefer ( "name" -- )
\ Revector kernel word to user defer.
\ Needed for standalone revectoring.
\ Get original xt:
  >in @ >r '
\ Force "name" to be deferred if it is
\ not already:
  r@ >in !  force-defer
\ Fetch original action:
  r@ >in !  '  defer@
\ Create a new user-deferred word:
\ ('redefined' warning is normal here)
  r@ >in !  defer
\ Assign old action to new defer:
  r@ >in !  ' defer! 
\ Re-vector original word to new one:
  r> >in !  ' swap defer! ;

end-module
